home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ADA Programming Guide
/
ADA Programming Guide.iso
/
ada_gnu
/
adainc
/
s-finimp.adb
< prev
next >
Wrap
Text File
|
1996-01-30
|
4KB
|
111 lines
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N --
-- --
-- B o d y --
-- --
-- $Revision: 1.14 $ --
-- --
-- Copyright (c) 1992,1993,1994 NYU, All Rights Reserved --
-- --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software Foundation; either version 2, or (at your option) any --
-- later version. The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY; without even the implied warranty --
-- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- Library General Public License for more details. You should have --
-- received a copy of the GNU Library General Public License along with --
-- the GNAT library; see the file COPYING.LIB. If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
with Ada.Finalization; use Ada.Finalization;
package body System.Finalization_Implementation is
--------------------------
-- Attach_To_Final_List --
--------------------------
procedure Attach_To_Final_List (
L : in out Finalizable_Ptr;
Obj : in out Finalizable) is
begin
if L /= null then
Obj.Next := L;
Finalizable (L.all).Prev := Obj'Access;
else
Obj.Next := null;
end if;
Obj.Prev := null;
L := Obj'Access;
end Attach_To_Final_List;
-------------------
-- Finalize_List --
-------------------
procedure Finalize_List (L : Finalizable_Ptr) is
P : Finalizable_Ptr := L;
Q : Finalizable_Ptr;
Error : Boolean := False;
begin
-- ??? pragma Abort_Defer;
while P /= null loop
Q := Finalizable (P.all).Next;
begin
Finalize (Root'Class (P.all));
exception
when others => Error := True;
end;
P := Q;
end loop;
if Error then
raise Program_Error;
end if;
end Finalize_List;
procedure Finalize_Global_List is
begin
Finalize_List (Global_Final_List);
end Finalize_Global_List;
------------------
-- Finalize_One --
------------------
procedure Finalize_One (
From : in out Finalizable_Ptr;
Obj : in out Finalizable) is
begin
-- ??? pragma Abort_Defer;
if Obj.Prev = null then
-- It must be the first of the list
From := Obj.Next;
else
Finalizable (Obj.Prev.all).Next := Obj.Next;
end if;
if Obj.Next /= null then
Finalizable (Obj.Next.all).Prev := Obj.Prev;
end if;
Finalize (Root'Class (Obj));
exception
when others => raise Program_Error;
end Finalize_One;
end System.Finalization_Implementation;